module AbsCSupport where

import AbsC
import PrintC
import Env

stringToId :: String -> Id
stringToId s = Id s

idToString :: Id -> String
idToString (Id s) = s

isBasic (BType _) = True
isBasic _         = False

elemType :: Type -> String -> Type
elemType t@(BType _) pos = TErr $ pos++" type "++printTree t++" cannot be used in an array initialization.\n" 
elemType (PType t) _ = t
elemType (Array _ t) _ = t

unPointer :: Type -> String -> Type
unPointer t s = case t of
   PType t1 -> t1
   Array _ t1 -> t1
   _ -> TErr s

maxType :: Type -> Type -> String -> Type
maxType (TErr _) (TErr _) pos = TErr $ pos++" invalid types.\n"
maxType (TErr _) t _ = t
maxType t@(BType BTChar) t2 pos = case t2 of
   TErr _ -> t
   BType BTChar -> t
   BType BTInt -> t2
   BType BTFloat -> t2
   _ -> TErr $ pos++" provided incompatible types "++printTree t++" and "++printTree t2++".\n" 

maxType t@(BType BTInt) t2 pos = case t2 of
   TErr _ -> t
   BType BTChar -> t
   BType BTInt -> t
   BType BTFloat -> t2
   BType _ -> TErr $ pos++" provided incompatible types "++printTree t++" and "++printTree t2++".\n" 
   PType _ -> t2
   Array _ _ -> t2

maxType t@(BType BTFloat) t2 pos = case t2 of
   TErr _ -> t
   BType BTChar -> t
   BType BTInt -> t
   BType BTFloat -> t
   _ -> TErr $ pos++" provided incompatible types "++printTree t++" and "++printTree t2++".\n" 

maxType t@(BType _) t2 pos = meetTypeRigid t t2 pos ""

maxType t@(PType t1) t2 pos = case t2 of
   TErr _ -> t
   BType _ -> maxType t2 t pos
   PType t2' -> if t1 == BType BTVoid || t2' == BType BTVoid then t else PType $ maxType t1 t2' pos
   Array _ t2' -> if t1 == BType BTVoid then t else PType $ maxType t1 t2' pos

maxType t@(Array n t1) t2 pos = case t2 of
   TErr _ -> t
   BType _ -> maxType t2 t pos
   PType t2' -> maxType t2 t pos
   Array m t2' -> Array (max n m) $ maxType t2' t1 pos

meetTypeRigid :: Type -> Type -> String -> String -> Type
meetTypeRigid (TErr _) (TErr _) pos s = TErr $ pos++" invalid types"++s
meetTypeRigid (TErr _) t _ _ = t

meetTypeRigid t@(BType BTChar) t2 pos s = case t2 of
   TErr _ -> t
   BType BTChar -> t
   _ -> TErr $ pos++" provided incompatible types "++printTree t++" and "++printTree t2++s 

meetTypeRigid t@(BType BTInt) t2 pos s = case t2 of
   TErr _ -> t
   BType BTChar -> t
   BType BTInt -> t
   BType _ -> TErr $ pos++" provided incompatible types "++printTree t++" and "++printTree t2++s 
   PType _ -> t
   Array _ _ -> t

meetTypeRigid t@(BType BTFloat) t2 pos s = case t2 of
   TErr _ -> t
   BType BTChar -> t
   BType BTInt -> t
   BType BTFloat -> t
   _ -> TErr $ pos++" provided incompatible types "++printTree t++" and "++printTree t2++s 

meetTypeRigid t@(BType _) (TErr _) _ _ = t

meetTypeRigid t@(PType t1) t2 pos s = case t2 of
   TErr _ -> t
   BType BTChar -> t
   BType BTInt -> t
   BType _ -> TErr $ pos++" provided incompatible types "++printTree t++" and "++printTree t2++s 
   PType t2' -> if t1 == BType BTVoid then t else PType $ meetTypeRigid t1 t2' pos s
   Array _ t2' -> if t1 == BType BTVoid then t else PType $ meetTypeRigid t1 t2' pos s

meetTypeRigid t@(Array _ _) (TErr _) _ _ = t
meetTypeRigid (Array n t) (Array m t') pos s
   | n == m = Array n $ meetTypeRigid t t' pos s
   | otherwise = TErr $ pos++" incompatible array dimension: "++show n++" and "++show m++".\n"

meetTypeRigid x y p s
 | x == y    = x
 | otherwise = TErr $ p++" incompatible types "++printTree x++" and "++printTree y++ s

widenType t t1 e
   |t == t1 = e
   |otherwise = Coertion t t1 e
 
validVarType :: Type -> String -> Type
validVarType t s = case t of
   BType BTVoid -> te
   Array _ tt -> validVarType tt s
   PType tt -> if isBasic tt then t else validVarType tt s
   TErr _ -> te
   _ -> t
   where
      te = TErr s


validArithOpType Pow t@(BType BTInt) _ _ = t
validArithOpType Pow t@(BType BTFloat) _ _ = t
validArithOpType Pow t p s = TErr $ p++" invalid type "++printTree t++" for operator "++printTree Pow++ s
validArithOpType aOp t@(BType BTChar) _ _ = t
validArithOpType aOp t@(BType BTInt) _ _ = t
validArithOpType aOp t@(BType BTFloat) _ _ = t
validArithOpType aOp t@(PType _) _ _ = t
validArithOpType aOp t p s = TErr $ p++" invalid type "++printTree t++" for operator "++printTree aOp++ s

validUnaryOpType aOp t@(BType BTChar) _  _= t
validUnaryOpType aOp t@(BType BTInt) _  _= t
validUnaryOpType aOp t@(BType BTFloat) _  _= t
validUnaryOpType aOp t@(PType _) _ _ = t
validUnaryOpType aOp t p s = TErr $ p++" invalid type "++printTree t++" for operator "++printTree aOp++ s

validProg :: [Decl] -> Env -> Program
validProg ds env = case lookupFun env mainf of
   FErr s -> Prog ds s
   _ -> Prog ds ""
   where
      mainf = funIdent (stringToId "main") []

validDeclFun :: Id -> [Parameter] -> Type -> Stmt -> Bool -> DefVars -> Env -> String -> Decl
validDeclFun i ps t bs unRet dvars env pos = case lookFun env fi of
   Just (FI _ _ n) -> if n /= length ps then d t' else d terr
   _ -> d t'
   where
      fi = funIdent i ps
      d dType= DFun dType fi ps bs
      terr = TErr $ pos++" function " ++ printTree fi ++ " has already been defined.\n"
      t' = unsFunReturn unRet
      unsFunReturn True = TErr $ pos++" function \""++printTree fi++"\" has no return statement defined.\n"
      unsFunReturn False = t
      
validDeclVar :: Id -> Type -> (Maybe InitVar) -> PCOffset -> Env -> String -> Decl
validDeclVar i t m p e pos = case lookVar e i of
   Just _ -> DVar (TErr twiceDecl) i m p
   _ -> DVar (validVarType t invType) i m p
   where
      twiceDecl = pos++" variable \"" ++ printTree i ++ "\" has already been declared.\n"
      invType = pos++" variable \"" ++ printTree i ++ "\" can't be declared of type " ++ printTree t ++ ".\n"

validEVar :: String -> InitVar
validEVar pos = EVar $ TErr $ pos++" an array initialization cannot be empty.\n"

validSIVar :: Type -> (RExpr,Type) -> String -> InitVar
validSIVar (TErr _) r _= SIVar r
validSIVar t (r@(Const _),t1) pos
   |t' == t = SIVar (r',t)
   |otherwise = SIVar (r,te)
      where
         t' = maxType t t1 pos
         r' = widenType t1 t r
         te = TErr $ pos++" invalid coertion from type "++printTree t1++" to "++printTree t++".\n"
validSIVar _ (r,_) pos = SIVar (r,te)
   where
      te = TErr $ pos++" expression \"("++printTree r++")\" cannot be used in a definition, because it is not a constant.\n"

validCIVar :: Type -> [InitVar] -> String -> InitVar
validCIVar t [] pos = validEVar pos
validCIVar a@(Array i _) is pos
   |i == i' = CIVar is a
   |otherwise = CIVar is le
      where
         i' = length is
         le = TErr $ pos++" actual initialization array length \""++show i'++"\" must be equal to the declared array length \""++show i++"\".\n"
validCIVar p@(PType _) is _ = CIVar is p
validCIVar t is pos = CIVar is te
   where
      te = TErr $ pos++" basic type "++printTree t++" cannot be used in an array initialization.\n"

validRExprUnaryOp :: UnaryOp -> (RExpr, Type) -> String -> (RExpr, Type) 
validRExprUnaryOp Not (r, t) pos = e
   where
      e = (UnaryOp Not r1,tb)
      tb = BType BTBool
      t1 = meetTypeRigid tb t pos $ " in expression \"("++printTree r++ ")\".\n"
      r1 = (r, t1)

validRExprUnaryOp Neg (r, t) pos = e
   where
      e = (UnaryOp Neg r1,t')
      t1' = validUnaryOpType Neg t pos $ " in expression \"("++printTree r++ ")\".\n"
      t' = maxType t1' (BType BTInt) pos
      r1 = (widenType t t' r,t1')

validRExprInfArithOp :: ArithOp -> (RExpr, Type) -> (RExpr, Type) -> String -> (RExpr, Type) 
validRExprInfArithOp Pow (r1,t1) (r2,t2) pos = e
   where
      e = (InfixOp (ArithOp Pow) e1 e2,t)
      t1' = validArithOpType Pow t1 pos $ " in expression \"("++printTree r1++ ")\".\n"
      t = maxType t1' ti pos
      t2' = meetTypeRigid ti t2 pos $ " in expression \"("++printTree r2++ ")\".\n"
      ti = BType BTInt
      e1 = (widenType t1 t r1, t1')
      e2 = (widenType t2 ti r2, t2')
validRExprInfArithOp Mod (r1,t1) (r2,t2) pos = e
   where
      e = (InfixOp (ArithOp Mod) e1 e2,ti)
      t1' = meetTypeRigid ti t1 pos $ " in expression \"( "++printTree r1++ " )\".\n"
      t2' = meetTypeRigid ti t2 pos $ " in expression \"( "++printTree r2++ " )\".\n"
      ti = BType BTInt
      e1 = (widenType t1 ti r1, t1')
      e2 = (widenType t2 ti r2, t2')
               
validRExprInfArithOp aOp (r1,t1) (r2,t2) pos = e
   where
      e = (InfixOp (ArithOp aOp) e1 e2,t)
      t1' = validArithOpType aOp t1 pos $ " in expression \"( "++printTree r1++ " )\".\n"
      t2' = validArithOpType aOp t2 pos $ " in expression \"( "++printTree r2++ " )\".\n"
      t = maxType t1' t2' pos
      e1 = (widenType t1 t r1, t1')
      e2 = (widenType t2 t r2, t2')

validRExprInfRelOp :: RelOp -> (RExpr, Type) -> (RExpr, Type) -> String -> (RExpr, Type)
validRExprInfRelOp rOp (r1,t1) (r2,t2) pos = e
   where
      e = (InfixOp (RelOp rOp) e1 e2,tb)
      t = maxType t1 t2 pos
      tb = BType BTBool
      e1 = (widenType t1 t r1, t)
      e2 = (widenType t2 t r2, t)
               
validRExprInfBoolOp :: BoolOp -> (RExpr, Type) -> (RExpr, Type) -> String -> (RExpr, Type)
validRExprInfBoolOp bOp (r1,t1) (r2,t2) pos = e
   where
      e = (InfixOp (BoolOp bOp) e1 e2,t)
      t = BType BTBool
      t1' = meetTypeRigid t t1 pos $ " in expression \"("++printTree r1++ ")\".\n"
      t2' = meetTypeRigid t t2 pos $ " in expression \"("++printTree r2++ ")\".\n"
      e1 = (r1, t1')
      e2 = (r2, t2')

validRExprFunCall :: Env -> Id -> [(RExpr, Type)] -> String -> (RExpr, Type)
validRExprFunCall e i ats pos = case lookupFun e fi of
   FI ps t _ -> (FCall fi $ zipWith (checkParam pos) ps ats, t)
   FErr s -> (FCall fi ats, TErr $ pos++s)
   where
      fi = funIdent i ats

checkParam :: String -> Parameter -> (RExpr,Type) -> (RExpr,Type)
checkParam pos (Param Modality_valres t i) (r, t1) = case r of
   LExpr _ -> r'
   _ -> rm
   where 
      mod = pos++" formal parameter \""++printTree i++"\" has modality "++printTree Modality_valres++
         ", while actual expression \"("++printTree r++")\" is not compatible with this modality.\n"
      r' = (widenType t1 t r, tt)
      rm = (widenType t1 t r, TErr mod)
      tt = meetTypeRigid t t1 pos $ " in expression \"("++printTree r++ ")\".\n"
      
checkParam pos (Param m t i) (r, t1) = r'
    where 
      r' = (widenType t1 t r, tt)
      tt = meetTypeRigid t t1 pos $ " in expression \"("++printTree r++ ")\".\n"
      
validAssign :: AssignmentOp -> (LExpr, Type) -> (RExpr, Type) -> String -> Stmt
validAssign Assign l@(l1,t1) (r1, t2) pos = e
   where
      e = Assgn Assign l r
      r = (widenType t2 t1 r1, tt)
      tt = meetTypeRigid t1 t2 pos $ " in expression \"("++printTree r1++ ")\".\n"
      
validAssign (AssgnArith Pow) l@(l1,t1) (r1, t2) pos = e
   where
      e = Assgn (AssgnArith Pow) (l1,t') r
      t' = validArithOpType Pow t1 pos $ " in expression \"("++printTree l1++ ")\".\n"
      ti = BType BTInt
      t2' = meetTypeRigid ti t2 pos $ " in expression \"("++printTree r1++ ")\".\n"
      r = (widenType t2 ti r1, t2')

validAssign (AssgnArith aOp) l@(l1,t1) (r1, t2) pos = e
   where
      e = Assgn (AssgnArith aOp) (l1,t') r
      t' = validArithOpType aOp t1 pos $ " in expression \"("++printTree l1++ ")\".\n"
      t = meetTypeRigid t1 t2 pos $ " in expression \"("++printTree r1++ ")\".\n"
      r = (widenType t2 t1 r1, t)

validAssign (AssgnBool bOp) (l,t1) (r,t2) pos= e
   where
      e = Assgn (AssgnBool bOp) (l,t) r'
      tb = BType BTBool
      r' = (r, t')
      t' = meetTypeRigid tb t2 pos $ " in expression \"("++printTree r++")\"\n."
      t = meetTypeRigid tb t1 pos $ " in expression \"("++printTree l++")\"\n."

validLExpr :: (LExpr,Type) -> (RExpr, Type)
validLExpr l@(_,t) = (LExpr l, t)

validRef :: (LExpr,Type) -> (RExpr,Type)
validRef l@(_,t) = (Ref l, t')
   where
      t' = pointer t
      pointer e@(TErr _) = e
      pointer t = PType t

validPrePostIncDecr :: PrePostIncDecr -> (LExpr,Type) -> String -> (RExpr,Type)
validPrePostIncDecr pp (l,t) pos = (PrePostIncDecr pp (l,t), t')
   where
      t' = vPPID t
      vPPID b@(BType BTChar) = b
      vPPID b@(BType BTInt) = b
      vPPID b@(BType BTFloat) = b
      vPPID b@(PType _) = b
      vPPID b@(Array _ _) = b
      vPPID b = TErr $ pos++" type "++printTree b++" is not a valid type for \""++printTree pp++"\" operation\n."  

validDeref :: (RExpr, Type) -> String -> (LExpr,Type)
validDeref f@(r,t) pos = (Deref f, t')
   where
      t' = unPointer t $ pos++" expression \"("++printTree r++")\" is not a pointer type.\n"

validArrayEl :: (LExpr,Type) -> (RExpr,Type) -> String -> (LExpr,Type)
validArrayEl ll@(l,t) (r,t1) pos = (ArrayEl ll r', tt)
   where
      ti = BType BTInt
      t' = meetTypeRigid ti t1 pos $ " in \"("++printTree r++")\"\n."
      r' = (widenType t1 ti r, t')
      tt = unPointer t $ pos++" expression \"("++printTree l++")\" is not a pointer or array.\n"
      
rExprCheck :: Id -> DefVars -> Env -> String -> (LExpr,Type)
rExprCheck i ds e pos = (l,t)
   where
      t = vType pos $ lookupVar e i
      l = SId i def
      def = varDefined i ds pos
         
assgnCheck :: AssignmentOp -> Id -> DefVars -> Env -> String -> (LExpr,Type)
assgnCheck Assign i ds e pos = (l,t)
   where
      l = SId i ""
      t = vType pos $ lookupVar e i
assgnCheck (AssgnArith aOp) i ds e pos = (l,t)
   where
      t = vType pos $ lookupVar e i
      l = SId i def
      def = varDefined i ds pos
assgnCheck (AssgnBool bOp) i ds e pos = (l,t)
   where
      t = vType pos $ lookupVar e i
      tb = BType BTBool
      l = SId i def
      def = varDefined i ds pos 
      
varDefined :: Id -> DefVars -> String -> String
varDefined x xs pos
   |elem x xs = ""
   |otherwise = pos++" variable \""++printTree x++"\" is never initialized.\n"
      
validBreak :: Bool -> String -> Stmt
validBreak True _= Jmp $ Break ""
validBreak _ pos = Jmp $ Break $ pos++" invalid use of statement break.\n" 

validContinue :: Bool -> String -> Stmt
validContinue True _ = Jmp $ Continue ""
validContinue _ pos = Jmp $ Continue $ pos++" invalid use of statement continue.\n"

validReturnVoid :: Type -> String -> Stmt
validReturnVoid t@(BType BTVoid) _= Jmp $ RetExpVoid t
validReturnVoid t pos = Jmp $ RetExpVoid $ TErr $ pos++" expected function return type is "++printTree t++" while actual return type is void.\n"

validReturn :: Type -> (RExpr, Type) -> String -> Stmt
validReturn t1 (r, t2) pos = Jmp $ RetExp r'
    where
      t = meetTypeRigid t1 t2 pos $ " in \"("++printTree r++")\".\n"
      r' = (widenType t2 t1 r, t)      

validStmtIf :: (RExpr, Type) -> Stmt -> String -> Stmt
validStmtIf (r,t) (Sel (IfNoElse _ s)) pos = s'
   where
      s' = Sel (IfNoElse (r,t') s)
      t' = meetTypeRigid tb t pos $ " If guard type must be boolean in \"("++printTree r++")\".\n"
      tb = BType BTBool

validStmtIf (r,t) (Sel (IfElse _ s1 s2)) pos = s'
   where
      s' = Sel (IfElse (r,t') s1 s2)
      t' = meetTypeRigid tb t pos $ " IfElse guard type must be boolean in \"("++printTree r++")\".\n"
      tb = BType BTBool

validStmtIf (r,t) (Iter (DoWhile s _)) pos = s'
   where
      s' = Iter (DoWhile s (r,t'))
      t' = meetTypeRigid tb t pos $ " DoWhile guard type must be boolean in \"("++printTree r++")\".\n"
      tb = BType BTBool

validStmtIf (r,t) (Iter (While _ s)) pos = s'
   where
      s' = Iter (While (r,t') s)
      t' = meetTypeRigid tb t pos $ " While guard type must be boolean in \"("++printTree r++")\".\n"
      tb = BType BTBool
